home *** CD-ROM | disk | FTP | other *** search
/ Language/OS - Multiplatform Resource Library / LANGUAGE OS.iso / gnu / emacs.lha / emacs-19.16 / lisp / rmailsort.el < prev    next >
Lisp/Scheme  |  1993-06-21  |  7KB  |  201 lines
  1. ;;; rmailsort.el --- Rmail: sort messages.
  2.  
  3. ;; Copyright (C) 1990, 1993 Free Software Foundation, Inc.
  4.  
  5. ;; Author: Masanobu UMEDA <umerin@mse.kyutech.ac.jp>
  6. ;; Version: $Header: /home/fsf/rms/e19/lisp/RCS/rmailsort.el,v 1.15 1993/06/22 05:55:41 rms Exp $
  7. ;; Keywords: mail
  8.  
  9. ;; This file is part of GNU Emacs.
  10.  
  11. ;; GNU Emacs is free software; you can redistribute it and/or modify
  12. ;; it under the terms of the GNU General Public License as published by
  13. ;; the Free Software Foundation; either version 2, or (at your option)
  14. ;; any later version.
  15.  
  16. ;; GNU Emacs is distributed in the hope that it will be useful,
  17. ;; but WITHOUT ANY WARRANTY; without even the implied warranty of
  18. ;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the
  19. ;; GNU General Public License for more details.
  20.  
  21. ;; You should have received a copy of the GNU General Public License
  22. ;; along with GNU Emacs; see the file COPYING.  If not, write to
  23. ;; the Free Software Foundation, 675 Mass Ave, Cambridge, MA 02139, USA.
  24.  
  25. ;;; Code:
  26.  
  27. (require 'sort)
  28.  
  29. (autoload 'timezone-make-date-sortable "timezone")
  30.  
  31. ;; Sorting messages in Rmail buffer
  32.  
  33. (defun rmail-sort-by-date (reverse)
  34.   "Sort messages of current Rmail file by date.
  35. If prefix argument REVERSE is non-nil, sort them in reverse order."
  36.   (interactive "P")
  37.   (rmail-sort-messages reverse
  38.                (function
  39.             (lambda (msg)
  40.               (rmail-make-date-sortable
  41.                (rmail-fetch-field msg "Date"))))))
  42.  
  43. (defun rmail-sort-by-subject (reverse)
  44.   "Sort messages of current Rmail file by subject.
  45. If prefix argument REVERSE is non-nil, sort them in reverse order."
  46.   (interactive "P")
  47.   (rmail-sort-messages reverse
  48.                (function
  49.             (lambda (msg)
  50.               (let ((key (or (rmail-fetch-field msg "Subject") ""))
  51.                 (case-fold-search t))
  52.                 ;; Remove `Re:'
  53.                 (if (string-match "^\\(re:[ \t]+\\)*" key)
  54.                 (substring key (match-end 0)) key))))))
  55.  
  56. (defun rmail-sort-by-author (reverse)
  57.   "Sort messages of current Rmail file by author.
  58. If prefix argument REVERSE is non-nil, sort them in reverse order."
  59.   (interactive "P")
  60.   (rmail-sort-messages reverse
  61.                (function
  62.             (lambda (msg)
  63.               (downcase    ;Canonical name
  64.                (mail-strip-quoted-names
  65.                 (or (rmail-fetch-field msg "From")
  66.                 (rmail-fetch-field msg "Sender") "")))))))
  67.  
  68. (defun rmail-sort-by-recipient (reverse)
  69.   "Sort messages of current Rmail file by recipient.
  70. If prefix argument REVERSE is non-nil, sort them in reverse order."
  71.   (interactive "P")
  72.   (rmail-sort-messages reverse
  73.                (function
  74.             (lambda (msg)
  75.               (downcase    ;Canonical name
  76.                (mail-strip-quoted-names
  77.                 (or (rmail-fetch-field msg "To")
  78.                 (rmail-fetch-field msg "Apparently-To") "")
  79.                 ))))))
  80.  
  81. (defun rmail-sort-by-correspondent (reverse)
  82.   "Sort messages of current Rmail file by other correspondent.
  83. If prefix argument REVERSE is non-nil, sort them in reverse order."
  84.   (interactive "P")
  85.   (rmail-sort-messages reverse
  86.                (function
  87.             (lambda (msg)
  88.               (rmail-select-correspondent
  89.                msg
  90.                '("From" "Sender" "To" "Apparently-To"))))))
  91.  
  92. (defun rmail-select-correspondent (msg fields)
  93.   (let ((ans ""))
  94.     (while (and fields (string= ans ""))
  95.       (setq ans
  96.         (rmail-dont-reply-to
  97.          (mail-strip-quoted-names
  98.           (or (rmail-fetch-field msg (car fields)) ""))))
  99.       (setq fields (cdr fields)))
  100.     ans))
  101.  
  102. (defun rmail-sort-by-lines (reverse)
  103.   "Sort messages of current Rmail file by number of lines.
  104. If prefix argument REVERSE is non-nil, sort them in reverse order."
  105.   (interactive "P")
  106.   (rmail-sort-messages reverse
  107.                (function
  108.             (lambda (msg)
  109.               (count-lines (rmail-msgbeg msgnum)
  110.                        (rmail-msgend msgnum))))))
  111.  
  112. ;; Basic functions
  113.  
  114. (defun rmail-sort-messages (reverse keyfun)
  115.   "Sort messages of current Rmail file.
  116. If 1st argument REVERSE is non-nil, sort them in reverse order.
  117. 2nd argument KEYFUN is called with a message number, and should return a key."
  118.   (let ((buffer-read-only nil)
  119.     (predicate nil)            ;< or string-lessp
  120.     (sort-lists nil))
  121.     (message "Finding sort keys...")
  122.     (widen)
  123.     (let ((msgnum 1))
  124.       (while (>= rmail-total-messages msgnum)
  125.     (setq sort-lists
  126.           (cons (list (funcall keyfun msgnum) ;Make sorting key
  127.               (eq rmail-current-message msgnum) ;True if current
  128.               (aref rmail-message-vector msgnum)
  129.               (aref rmail-message-vector (1+ msgnum)))
  130.             sort-lists))
  131.     (if (zerop (% msgnum 10))
  132.         (message "Finding sort keys...%d" msgnum))
  133.     (setq msgnum (1+ msgnum))))
  134.     (or reverse (setq sort-lists (nreverse sort-lists)))
  135.     ;; Decide predicate: < or string-lessp
  136.     (if (numberp (car (car sort-lists))) ;Is a key numeric?
  137.     (setq predicate (function <))
  138.       (setq predicate (function string-lessp)))
  139.     (setq sort-lists
  140.       (sort sort-lists
  141.         (function
  142.          (lambda (a b)
  143.            (funcall predicate (car a) (car b))))))
  144.     (if reverse (setq sort-lists (nreverse sort-lists)))
  145.     ;; Now we enter critical region.  So, keyboard quit is disabled.
  146.     (message "Reordering messages...")
  147.     (let ((inhibit-quit t)        ;Inhibit quit
  148.       (current-message nil)
  149.       (msgnum 1)
  150.       (msginfo nil))
  151.       ;; There's little hope that we can easily undo after that.
  152.       (buffer-flush-undo (current-buffer))
  153.       (goto-char (rmail-msgbeg 1))
  154.       ;; To force update of all markers.
  155.       (insert-before-markers ?Z)
  156.       (backward-char 1)
  157.       ;; Now reorder messages.
  158.       (while sort-lists
  159.     (setq msginfo (car sort-lists))
  160.     ;; Swap two messages.
  161.     (insert-buffer-substring
  162.      (current-buffer) (nth 2 msginfo) (nth 3 msginfo))
  163.     (delete-region  (nth 2 msginfo) (nth 3 msginfo))
  164.     ;; Is current message?
  165.     (if (nth 1 msginfo)
  166.         (setq current-message msgnum))
  167.     (setq sort-lists (cdr sort-lists))
  168.     (if (zerop (% msgnum 10))
  169.         (message "Reordering messages...%d" msgnum))
  170.     (setq msgnum (1+ msgnum)))
  171.       ;; Delete the garbage inserted before.
  172.       (delete-char 1)
  173.       (setq quit-flag nil)
  174.       (buffer-enable-undo)
  175.       (rmail-set-message-counters)
  176.       (rmail-show-message current-message))
  177.     ))
  178.  
  179. (defun rmail-fetch-field (msg field)
  180.   "Return the value of the header FIELD of MSG.
  181. Arguments are MSG and FIELD."
  182.   (save-restriction
  183.     (widen)
  184.     (let ((next (rmail-msgend msg)))
  185.       (goto-char (rmail-msgbeg msg))
  186.       (narrow-to-region (if (search-forward "\n*** EOOH ***\n" next t)
  187.                 (point)
  188.               (forward-line 1)
  189.               (point))
  190.             (progn (search-forward "\n\n" nil t) (point)))
  191.       (mail-fetch-field field))))
  192.  
  193. (defun rmail-make-date-sortable (date)
  194.   "Make DATE sortable using the function string-lessp."
  195.   ;; Assume the default time zone is GMT.
  196.   (timezone-make-date-sortable date "GMT" "GMT"))
  197.  
  198. (provide 'rmailsort)
  199.  
  200. ;;; rmailsort.el ends here
  201.